home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PsL Monthly 1993 December
/
PSL Monthly Shareware CD-ROM (December 1993).iso
/
prgmming
/
dos
/
pascal
/
shazam.exe
/
GVIDEO.IMP
< prev
next >
Wrap
Text File
|
1992-09-01
|
8KB
|
257 lines
{*******************************************************************
GVIDEO.IMP
*******************************************************************}
{===================================================================
BORDER. Color Range is 0..15 (same as CRT unit constants)
0-Black 4-Red 8-DarkGray 12-LightRed
1-Blue 5-Magenta 9-LightBlue 13-LightMagenta
2-Green 6-Brown 10-LightGreen 14-Yellow
3-Cyan 7-LightGray 11-LightCyan 15-White
Certain EGA/VGA systems have modified BIOS' which messes up the
palette. Noted on an external color monitor for a "lunchbox"
portable with built-in plasma display; apparently, manufacturer
attempts to simulate color with shading.
===================================================================}
procedure SetBorder ( Color : byte ) ;
var
R : Registers ;
begin
if not AllowBorderColors then EXIT ; { global option }
if Application <> NIL then
if AppPalette <> apColor then
Color := 0 ; { BLACK }
with R do
begin
AH := $0B ;
BH := $00 ;
BL := Color ;
Intr ( $10 , R ) ;
end ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
VIDEO
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
MONITOR TYPE
===================================================================}
function IsMono : boolean ;
var
CrtMode : byte ABSOLUTE $0040:$0049 ;
begin
IsMono := CrtMode = 7 ;
end ;
{===================================================================
VIDEO MEMORY
===================================================================}
function HardwareScreenBuffer : pointer ;
begin
if IsMono then
HardwareScreenBuffer := PTR ( $B000 , 0 )
else
HardwareScreenBuffer := PTR ( $B800 , 0 ) ;
end ;
{===================================================================
VIDEO MEMORY - automatic DesqView support (see APP.PAT for APP.PAS)
===================================================================}
function MyScreenBuffer : pointer ;
var
DesqViewScreen : word ;
begin
{$IFDEF desqview }
DesqViewScreen := DV_Get_Video_Buffer ;
if DesqViewScreen > 0 then
MyScreenBuffer := PTR ( DESQviewScreen , 0 )
else
{$ENDIF}
MyScreenBuffer := HardwareScreenBuffer ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
SCREEN PUSH/POP
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
VIDEO
Note: Non-standard super-VGA may not update correctly.
Became valid starting with EGA cards.
===================================================================}
function BiosHeight : byte ;
var
BiosScreenRows : byte ABSOLUTE $0040 : $0084 ;
begin
if BiosScreenRows = 0 then
BiosHeight := 25
else
BiosHeight := BiosScreenRows + 1 ;
end ;
function BiosWidth : byte ;
var
CrtMode : byte ABSOLUTE $0040:$0049 ;
begin
case CrtMode of
0 ,
1 : BiosWidth := 40 ;
2 ,
3 ,
7 : BiosWidth := 80 ;
else
BiosWidth := 80 ;
end ;
end ;
{===================================================================
BUFFER - calculate based on BIOS height
===================================================================}
function VideoBufSize : word ;
begin
VideoBufSize := BiosWidth * BiosHeight * 2 ;
end ;
{===================================================================
SAVE
===================================================================}
procedure PushScreen ;
var
Buf : pointer ;
begin
if SaveScreen <> NIL then EXIT ;
if VideoBufSize > MaxAvail then EXIT ;
OldX := WhereX ;
OldY := WhereY ;
OldBufSize := VideoBufSize ;
GetMem ( SaveScreen , OldBufSize ) ;
Buf := MyScreenBuffer ;
Move ( Mem [ Seg ( Buf^ ) : 0 ] , SaveScreen^ , OldBufSize ) ;
end ;
{===================================================================
SHOW
===================================================================}
procedure PullScreen ;
var
Buf : pointer ;
begin
if SaveScreen = NIL then EXIT ;
Buf := MyScreenBuffer ;
Move ( SaveScreen^, Mem [ Seg ( Buf^ ) : 0 ] , OldBufSize ) ;
GotoXY ( OldX , OldY ) ;
end ;
{===================================================================
FREE - Release memory without re-display
===================================================================}
procedure FreeScreen ;
begin
if SaveScreen = NIL then EXIT ;
FreeMem ( SaveScreen , OldBufSize ) ;
SaveScreen := NIL ;
end ;
{===================================================================
RESTORE
===================================================================}
procedure PopScreen ;
begin
PullScreen ;
FreeScreen ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
OFFSET
===================================================================}
function CharOffset ( x , y : byte ) : word ;
begin
if x < 1 then x := 1 ;
if y < 1 then y := 1 ;
if x > BiosWidth then x := BiosWidth ;
if y > BiosHeight then y := BiosHeight ;
CharOffset := ( ( Y - 1 ) * BiosWidth + x - 1 ) * 2 ;
end ;
{===================================================================
CHAR
===================================================================}
function GetChar ( x , y : byte ; Vid : pointer ) : char ;
begin
if Vid <> NIL then
GetChar := chr ( Mem [ Seg ( Vid^ ) :
CharOffset ( x , y ) ] )
else
GetChar := #0 ;
end ;
{===================================================================
LINE
===================================================================}
function GetLine ( y : byte ; Vid : pointer ) : string ;
var
x : byte ;
S : string ;
begin
S := '' ;
if Vid <> NIL then
for x := 1 to BiosWidth do
S := S + chr ( Mem [ Seg ( Vid^ ) :
CharOffset ( x , y ) ] ) ;
GetLine := S ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
INTERFACE
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
OFF
===================================================================}
procedure VisionOFF ;
begin
DoneSysError ;
DoneEvents ;
SaveSnow := DRIVERS.CheckSnow ; { InitVideo resets }
DoneVideo ;
DoneMemory ;
end ;
{===================================================================
ON
===================================================================}
procedure VisionON ;
begin
InitMemory ;
InitVideo ;
DRIVERS.CheckSnow := SaveSnow ; { InitVideo resets }
InitEvents ;
InitSysError ;
hdRefreshDisplay ;
end ;